home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / BUILTIN.C < prev    next >
C/C++ Source or Header  |  1991-11-20  |  39KB  |  1,252 lines
  1. /* --------------------------------------------------------------------------
  2.  * builtin.c:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21 November 1991
  5.  *
  6.  *        Last updated 03/11/91 mpj
  7.  *
  8.  * Primitive functions, input output etc...
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15. #include <ctype.h>
  16. #if TURBOC
  17. #include <io.h>
  18. #endif
  19.  
  20. Name nameFatbar, nameFail;        /* primitives reqd for translation */
  21. Name nameIf,     nameSel;
  22. Name nameMinus,  nameDivide;
  23.  
  24. Name nameUndefMem;            /* undefined member primitive       */
  25. Name nameError;                /* error primitive function       */
  26.  
  27. Name nameAnd,    nameOr;        /* built-in logical connectives       */
  28.  
  29. Name namePrint,  nameNPrint;        /* primitives for printing       */
  30.  
  31. static Name nameLPrint, nameNLPrint;    /* list printing primitives       */
  32. static Name nameSPrint, nameNSPrint;    /* string printing primitives       */
  33.  
  34. static Name nameInput;            /* For reading from stdin       */
  35.  
  36. /* --------------------------------------------------------------------------
  37.  * Local function prototypes:
  38.  * ------------------------------------------------------------------------*/
  39.  
  40. #define PROTO_PRIM(name)    static Void name Args((StackPtr))
  41. #define primFun(name)        static Void name(root) StackPtr root;
  42. #define primArg(n)        stack(root+n)
  43. #define update(l,r)        ((fst(stack(root))=l),(snd(stack(root))=r))
  44. #define updateRoot(c)        update(INDIRECT,c)
  45. #define updapRoot(l,r)        update(l,r)
  46. #define cantReduce()        evalFails(root)
  47.  
  48. PROTO_PRIM(primFatbar);
  49. PROTO_PRIM(primFail);
  50. PROTO_PRIM(primUndefMem);
  51. PROTO_PRIM(primSel);
  52. PROTO_PRIM(primIf);
  53. PROTO_PRIM(primStrict);
  54.  
  55. PROTO_PRIM(primPlusInt);
  56. PROTO_PRIM(primMinusInt);
  57. PROTO_PRIM(primMulInt);
  58. PROTO_PRIM(primDivInt);
  59. PROTO_PRIM(primModInt);
  60. PROTO_PRIM(primRemInt);
  61. PROTO_PRIM(primNegInt);
  62.  
  63. PROTO_PRIM(primCharToInt);
  64. PROTO_PRIM(primIntToChar);
  65. PROTO_PRIM(primIntToFloat);
  66.  
  67. PROTO_PRIM(primPlusFloat);
  68. PROTO_PRIM(primMinusFloat);
  69. PROTO_PRIM(primMulFloat);
  70. PROTO_PRIM(primDivFloat);
  71. PROTO_PRIM(primNegFloat);
  72.  
  73. PROTO_PRIM(primEqInt);
  74. PROTO_PRIM(primLeInt);
  75.  
  76. PROTO_PRIM(primEqFloat);
  77. PROTO_PRIM(primLeFloat);
  78.  
  79. PROTO_PRIM(primCmp);
  80. PROTO_PRIM(primGenericEq);
  81. PROTO_PRIM(primGenericLe);
  82. PROTO_PRIM(primGenericLt);
  83. PROTO_PRIM(primGenericGe);
  84. PROTO_PRIM(primGenericGt);
  85. PROTO_PRIM(primGenericNe);
  86.  
  87. PROTO_PRIM(primPrint);
  88. PROTO_PRIM(primNPrint);
  89.  
  90. static Void   local printer        Args((StackPtr,Name,Int,Cell));
  91. static Void   local startList        Args((StackPtr,Cell));
  92. static Void   local startNList        Args((StackPtr,Cell));
  93.  
  94. PROTO_PRIM(primLPrint);
  95. PROTO_PRIM(primNLPrint);
  96. PROTO_PRIM(primSPrint);
  97. PROTO_PRIM(primNSPrint);
  98.  
  99. static Cell   local textAsVar        Args((Text,Cell));
  100. static Cell   local textAsOp        Args((Text,Cell));
  101. static Cell   local stringOutput    Args((String,Cell));
  102. static Cell   local printBadRedex    Args((Cell,Cell));
  103.  
  104. static String local evalName        Args((Cell));
  105. static Void   local abandonDialogue    Args((Cell));
  106. static Cell   local printDBadRedex    Args((Cell,Cell));
  107. static Cell   local readFile        Args((Void));
  108. static Cell   local writeFile        Args((Void));
  109. static Cell   local appendFile        Args((Void));
  110. static Cell   local readChan        Args((Void));
  111. static Cell   local appendChan        Args((Void));
  112. static FILE  *local validOutChannel    Args((String));
  113. static Cell   local echo        Args((Void));
  114.  
  115. PROTO_PRIM(primInput);
  116.  
  117. /* --------------------------------------------------------------------------
  118.  * Table of primitive/built-in values:
  119.  * ------------------------------------------------------------------------*/
  120.  
  121. struct primitive primitives[] = {
  122.  
  123.   {"primPlusInt",  2, primPlusInt},    {"primMinusInt",  2, primMinusInt},
  124.   {"primMulInt",   2, primMulInt},     {"primDivInt",     2, primDivInt},
  125.   {"primModInt",   2, primModInt},     {"primRemInt",     2, primRemInt},
  126.   {"primNegInt",   1, primNegInt},
  127.  
  128.   {"primPlusFloat",2, primPlusFloat},  {"primMinusFloat",2, primMinusFloat},
  129.   {"primMulFloat", 2, primMulFloat},   {"primDivFloat",  2, primDivFloat},
  130.   {"primNegFloat", 1, primNegFloat},
  131.  
  132.   {"primIntToChar",1, primIntToChar},  {"primCharToInt", 1, primCharToInt},
  133.   {"primIntToFloat",1,primIntToFloat},
  134.  
  135.   {"primEqInt",    2, primEqInt},      {"primLeInt",     2, primLeInt},
  136.   {"primEqFloat",  2, primEqFloat},    {"primLeFloat",   2, primLeFloat},
  137.  
  138.   {"primGenericEq",2, primGenericEq},  {"primGenericNe", 2, primGenericNe},
  139.   {"primGenericGt",2, primGenericGt},  {"primGenericLe", 2, primGenericLe},
  140.   {"primGenericGe",2, primGenericGe},  {"primGenericLt", 2, primGenericLt},
  141.  
  142.   {"primPrint",    3, primPrint},
  143.  
  144.   {"primStrict",   2, primStrict},
  145.  
  146.   {0,           0, 0}
  147. };
  148.  
  149. /* --------------------------------------------------------------------------
  150.  * Primitive functions:
  151.  * ------------------------------------------------------------------------*/
  152.  
  153. primFun(primFatbar) {            /* Fatbar primitive           */
  154.     Cell l    = primArg(2);        /* _FAIL [] r = r           */
  155.     Cell r    = primArg(1);        /* l     [] r = l  -- otherwise       */
  156.     Cell temp = evalWithNoError(l);
  157.     if (nonNull(temp))
  158.     if (temp==nameFail)
  159.         updateRoot(r);
  160.     else {
  161.         updateRoot(temp);
  162.         cantReduce();
  163.     }
  164.     else
  165.     updateRoot(l);
  166. }
  167.  
  168. primFun(primFail) {               /* Failure primitive           */
  169.     cantReduce();
  170. }
  171.  
  172. primFun(primUndefMem) {               /* undefined member function        */
  173.     cantReduce();
  174. }
  175.  
  176. primFun(primSel) {               /* Component selection           */
  177.     Cell c = primArg(3);           /* _sel c e n   return nth component*/
  178.     Cell e = primArg(2);           /*           in expression e       */
  179.     Cell n = intOf(primArg(1));        /*           built using cfun c  */
  180.  
  181.     eval(e);
  182.     if (whnfHead==c &&    ((isName(whnfHead) && name(whnfHead).arity==whnfArgs)
  183.               || (isTuple(whnfHead) && tupleOf(whnfHead)==whnfArgs)))
  184.     updateRoot(pushed(n-1));
  185.     else
  186.     cantReduce();
  187. }
  188.  
  189. primFun(primIf) {               /* Conditional primitive        */
  190.     eval(primArg(3));
  191.     if (whnfHead==nameTrue)
  192.     updateRoot(primArg(2));
  193.     else
  194.     updateRoot(primArg(1));
  195. }
  196.  
  197. primFun(primStrict) {               /* Strict application primitive       */
  198.     eval(primArg(1));               /* evaluate 2nd argument        */
  199.     updapRoot(primArg(2),primArg(1));  /* and apply 1st argument to result */
  200. }
  201.  
  202. /* --------------------------------------------------------------------------
  203.  * Integer arithmetic primitives:
  204.  * ------------------------------------------------------------------------*/
  205.  
  206. primFun(primPlusInt) {               /* Integer addition primitive       */
  207.     Int x;
  208.     eval(primArg(2));
  209.     x = whnfInt;
  210.     eval(primArg(1));
  211.     updateRoot(mkInt(x+whnfInt));
  212. }
  213.  
  214. primFun(primMinusInt) {            /* Integer subtraction primitive    */
  215.     Int x;
  216.     eval(primArg(2));
  217.     x = whnfInt;
  218.     eval(primArg(1));
  219.     updateRoot(mkInt(x-whnfInt));
  220. }
  221.  
  222. primFun(primMulInt) {               /* Integer multiplication primitive */
  223.     Int x;
  224.     eval(primArg(2));
  225.     x = whnfInt;
  226.     eval(primArg(1));
  227.     updateRoot(mkInt(x*whnfInt));
  228. }
  229.  
  230. primFun(primDivInt) {               /* Integer division primitive       */
  231.     Int x;
  232.     eval(primArg(2));
  233.     x = whnfInt;
  234.     eval(primArg(1));
  235.  
  236.     if (whnfInt==0)
  237.     cantReduce();
  238.  
  239.     updateRoot(mkInt(x/whnfInt));
  240. }
  241.  
  242. primFun(primModInt) {               /* Integer modulo primitive       */
  243.     Int x,y;
  244.     eval(primArg(2));
  245.     x = whnfInt;
  246.     eval(primArg(1));
  247.     if (whnfInt==0)
  248.     cantReduce();
  249.     y = x%whnfInt;               /* "... the modulo having the sign  */
  250.     if ((x<0 && whnfInt>0) ||           /*           of the divisor ..." */
  251.     (x>0 && whnfInt<0))           /* See definition on p.81 of Haskell*/
  252.     updateRoot(mkInt(y+whnfInt));  /* report...               */
  253.     else
  254.     updateRoot(mkInt(y));
  255. }
  256.  
  257. primFun(primRemInt) {               /* Integer remainder primitive       */
  258.     Int x;
  259.     eval(primArg(2));               /* div and rem satisfy:           */
  260.     x = whnfInt;               /* (x `div` y)*y + (x `rem` y) == x */
  261.     eval(primArg(1));               /* which is exactly the property    */
  262.     if (whnfInt==0)               /* described in K&R 2:           */
  263.     cantReduce();               /*      (a/b)*b + a%b == a       */
  264.     updateRoot(mkInt(x%whnfInt));
  265. }
  266.  
  267. primFun(primNegInt) {               /* Integer negation primitive       */
  268.     eval(primArg(1));
  269.     updateRoot(mkInt(-whnfInt));
  270. }
  271.  
  272. /* --------------------------------------------------------------------------
  273.  * Coercion primitives:
  274.  * ------------------------------------------------------------------------*/
  275.  
  276. primFun(primCharToInt) {           /* Character to integer primitive   */
  277.     eval(primArg(1));
  278.     updateRoot(mkInt(charOf(whnfHead)));
  279. }
  280.  
  281. primFun(primIntToChar) {           /* Integer to character primitive   */
  282.     eval(primArg(1));
  283.     if (whnfInt<0  || whnfInt>MAXCHARVAL)
  284.     cantReduce();
  285.     updateRoot(mkChar(whnfInt));
  286. }
  287.  
  288. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  289.     eval(primArg(1));
  290.     updateRoot(mkFloat((Float)(whnfInt)));
  291. }
  292.  
  293. /* --------------------------------------------------------------------------
  294.  * Float arithmetic primitives:
  295.  * ------------------------------------------------------------------------*/
  296.  
  297. primFun(primPlusFloat) {           /* Float addition primitive       */
  298.     Float x;
  299.     eval(primArg(2));
  300.     x = whnfFloat;
  301.     eval(primArg(1));
  302.     updateRoot(mkFloat(x+whnfFloat));
  303. }
  304.  
  305. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  306.     Float x;
  307.     eval(primArg(2));
  308.     x = whnfFloat;
  309.     eval(primArg(1));
  310.     updateRoot(mkFloat(x-whnfFloat));
  311. }
  312.  
  313. primFun(primMulFloat) {               /* Float multiplication primitive   */
  314.     Float x;
  315.     eval(primArg(2));
  316.     x = whnfFloat;
  317.     eval(primArg(1));
  318.     updateRoot(mkFloat(x*whnfFloat));
  319. }
  320.  
  321. primFun(primDivFloat) {               /* Float division primitive       */
  322.     Float x;
  323.     eval(primArg(2));
  324.     x = whnfFloat;
  325.     eval(primArg(1));
  326.     if (whnfFloat==0)
  327.     cantReduce();
  328.     updateRoot(mkFloat(x/whnfFloat));
  329. }
  330.  
  331. primFun(primNegFloat) {               /* Float negation primitive       */
  332.     eval(primArg(1));
  333.     updateRoot(mkFloat(-whnfFloat));
  334. }
  335.  
  336. /* --------------------------------------------------------------------------
  337.  * Comparison primitives:
  338.  * ------------------------------------------------------------------------*/
  339.  
  340. primFun(primEqInt) {               /* Integer equality primitive       */
  341.     Int x;
  342.     eval(primArg(2));
  343.     x = whnfInt;
  344.     eval(primArg(1));
  345.     updateRoot(x==whnfInt ? nameTrue : nameFalse);
  346. }
  347.  
  348. primFun(primLeInt) {               /* Integer <= primitive           */
  349.     Int x;
  350.     eval(primArg(2));
  351.     x = whnfInt;
  352.     eval(primArg(1));
  353.     updateRoot(x<=whnfInt ? nameTrue : nameFalse);
  354. }
  355.  
  356. primFun(primEqFloat) {               /* Float equality primitive       */
  357.     Float x;
  358.     eval(primArg(2));
  359.     x = whnfFloat;
  360.     eval(primArg(1));
  361.     updateRoot(x==whnfFloat ? nameTrue : nameFalse);
  362. }
  363.  
  364. primFun(primLeFloat) {               /* Float <= primitive           */
  365.     Float x;
  366.     eval(primArg(2));
  367.     x = whnfFloat;
  368.     eval(primArg(1));
  369.     updateRoot(x<=whnfFloat ? nameTrue : nameFalse);
  370. }
  371.  
  372. /* Generic comparisons implemented using the internal primitive function:
  373.  *
  374.  * primCmp []            = EQ
  375.  *         ((C xs, D ys):rs)
  376.  *       | C < D        = LT
  377.  *       | C == D        = primCmp (zip xs ys ++ rs)
  378.  *       | C > D        = GT
  379.  *       ((Int n, Int m):rs)
  380.  *       | n < m        = LT
  381.  *       | n == m        = primCmp rs
  382.  *       | n > m        = GT
  383.  *       etc ... similar for comparison of characters:
  384.  *
  385.  * The list argument to primCmp is represented as an `internal list';
  386.  * i.e. no (:)/[] constructors - use internal cons and NIL instead!
  387.  *
  388.  * To compare two values x and y, evaluate primCmp [(x,y)] and use result.
  389.  */
  390.  
  391. #define LT            1
  392. #define EQ            2
  393. #define GT            3
  394. #define compResult(x) updateRoot(mkInt(x))
  395.  
  396. static Name namePrimCmp;
  397.  
  398. primFun(primCmp) {            /* generic comparison function       */
  399.     Cell rs = primArg(1);
  400.  
  401.     if (isNull(rs)) {
  402.     compResult(EQ);
  403.     return;
  404.     }
  405.     else {
  406.     Cell x = fst(hd(rs));
  407.     Cell y = snd(hd(rs));
  408.     Int  whnfArgs1;
  409.     Cell whnfHead1;
  410.  
  411.     rs = tl(rs);
  412.     eval(x);
  413.     whnfArgs1 = whnfArgs;
  414.     whnfHead1 = whnfHead;
  415.  
  416.     switch (whatIs(whnfHead1)) {
  417.         case INTCELL  : if (whnfArgs==0) {        /* compare ints    */
  418.                 eval(y);
  419.                 if (!isInt(whnfHead) || whnfArgs!=0)
  420.                     break;
  421.                 if (intOf(whnfHead1) > whnfInt)
  422.                     compResult(GT);
  423.                 else if (intOf(whnfHead1) < whnfInt)
  424.                     compResult(LT);
  425.                 else
  426.                     updapRoot(namePrimCmp,rs);
  427.                 return;
  428.                 }
  429.  
  430.         case FLOATCELL: if (whnfArgs==0) {        /* compare floats  */
  431.                 eval(y);
  432.                 if (!isFloat(whnfHead) || whnfArgs!=0)
  433.                     break;
  434.                 if (floatOf(whnfHead1) > whnfFloat)
  435.                     compResult(GT);
  436.                 else if (floatOf(whnfHead1) < whnfFloat)
  437.                     compResult(LT);
  438.                 else
  439.                     updapRoot(namePrimCmp,rs);
  440.                 return;
  441.                 }
  442.                 break;
  443.  
  444.         case CHARCELL : if (whnfArgs==0) {        /* compare chars   */
  445.                 eval(y);
  446.                 if (!isChar(whnfHead) || whnfArgs!=0)
  447.                     break;
  448.                 if (charOf(whnfHead1) > charOf(whnfHead))
  449.                     compResult(GT);
  450.                 else if (charOf(whnfHead1) < charOf(whnfHead))
  451.                     compResult(LT);
  452.                 else
  453.                     updapRoot(namePrimCmp,rs);
  454.                 return;
  455.                 }
  456.                 break;
  457.  
  458.         default      : eval(y);            /* compare structs */
  459.                 if (whnfHead1==whnfHead &&
  460.                 whnfArgs1==whnfArgs &&
  461.                 (whnfHead==UNIT    ||
  462.                  isTuple(whnfHead) ||
  463.                  (isName(whnfHead) &&
  464.                   name(whnfHead).defn==CFUN))) {
  465.                 while (whnfArgs1-- >0)
  466.                     rs = cons(pair(pushed(whnfArgs+whnfArgs1),
  467.                            pushed(whnfArgs1)),rs);
  468.                 updapRoot(namePrimCmp,rs);
  469.                 return;
  470.                 }
  471.                 if (isName(whnfHead1)        &&
  472.                  name(whnfHead1).defn==CFUN &&
  473.                  isName(whnfHead)        &&
  474.                  name(whnfHead).defn==CFUN) {
  475.                 if (name(whnfHead1).number
  476.                         > name(whnfHead).number)
  477.                     compResult(GT);
  478.                 else if (name(whnfHead1).number
  479.                         < name(whnfHead).number)
  480.                     compResult(LT);
  481.                 else
  482.                     break;
  483.                 return;
  484.                 }
  485.                             break;
  486.     }
  487.         /* we're going to fail because we can't compare x and y; modify    */
  488.     /* the root expression so that it looks reasonable before failing  */
  489.     /* i.e. output produced will be:  {_compare x y}           */
  490.     updapRoot(ap(namePrimCmp,x),y);
  491.     }
  492.     cantReduce();
  493. }
  494.  
  495. primFun(primGenericEq) {        /* Generic equality test       */
  496.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  497.     eval(c);
  498.     updateRoot(whnfInt==EQ ? nameTrue : nameFalse);
  499. }
  500.  
  501. primFun(primGenericLe) {        /* Generic <= test           */
  502.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  503.     eval(c);
  504.     updateRoot(whnfInt<=EQ ? nameTrue : nameFalse);
  505. }
  506.  
  507. primFun(primGenericLt) {        /* Generic < test           */
  508.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  509.     eval(c);
  510.     updateRoot(whnfInt<EQ ? nameTrue : nameFalse);
  511. }
  512.  
  513. primFun(primGenericGe) {        /* Generic >= test           */
  514.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  515.     eval(c);
  516.     updateRoot(whnfInt>=EQ ? nameTrue : nameFalse);
  517. }
  518.  
  519. primFun(primGenericGt) {        /* Generic > test           */
  520.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  521.     eval(c);
  522.     updateRoot(whnfInt>EQ ? nameTrue : nameFalse);
  523. }
  524.  
  525. primFun(primGenericNe) {        /* Generic /= test           */
  526.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  527.     eval(c);
  528.     updateRoot(whnfInt!=EQ ? nameTrue : nameFalse);
  529. }
  530.  
  531. /* --------------------------------------------------------------------------
  532.  * Print primitives:
  533.  * ------------------------------------------------------------------------*/
  534.  
  535. static Cell consOpen,    consSpace,  consComma,    consClose;
  536. static Cell consObrace, consCbrace, consOsq,    consCsq;
  537. static Cell consBack,    consMinus,  consQuote,  consDQuote;
  538.  
  539. #define print(pr,d,e,ss)    ap(ap(ap(pr,mkInt(d)),e),ss)
  540. #define lprint(pr,xs,ss)    ap(ap(pr,xs),ss)
  541. #define printString(s,ss)   revOnto(stringOutput(s,NIL),ss)
  542. #define printSChar(c,ss)    printString(unlexChar(c,'\"'),ss)
  543.  
  544. primFun(primPrint) {            /* evaluate and print term       */
  545.     Int  d    = intOf(primArg(3));    /*    :: Int->Expr->[Char]->[Char] */
  546.     Cell e    = primArg(2);
  547.     Cell ss   = primArg(1);
  548.     Cell temp = evalWithNoError(e);
  549.     if (nonNull(temp))
  550.     updateRoot(printBadRedex(temp,ss));
  551.     else
  552.     printer(root,namePrint,d,ss);
  553. }
  554.  
  555. primFun(primNPrint) {            /* print term without evaluation   */
  556.     Int    d      = intOf(primArg(3)); /*     :: Int->Expr->[Char]->[Char] */
  557.     Cell   e      = primArg(2);
  558.     Cell   ss      = primArg(1);
  559.     unwind(e);
  560.     printer(root,nameNPrint,d,ss);
  561. }
  562.  
  563. static Void local printer(root,pr,d,ss)    /* Main part: primPrint/primNPrint */
  564. StackPtr root;                /* root or print redex           */
  565. Name     pr;                /* printer to use on components       */
  566. Int     d;                /* precedence level           */
  567. Cell     ss; {                /* rest of output           */
  568.     Int  used    = 0;
  569.     Cell output = NIL;
  570.  
  571.     switch(whatIs(whnfHead)) {
  572.  
  573.     case NAME     : {   Syntax sy = syntaxOf(name(whnfHead).text);
  574.  
  575.                 if (name(whnfHead).defn!=CFUN ||
  576.                     name(whnfHead).arity>whnfArgs)
  577.                 pr = nameNPrint;
  578.  
  579.                 if (whnfHead==nameCons && whnfArgs==2) {/*list */
  580.                 if (pr==namePrint)
  581.                     startList(root,ss);
  582.                 else
  583.                     startNList(root,ss);
  584.                 return;
  585.                 }
  586.                 if (whnfArgs==1 && sy!=APPLIC) {      /* (e1+) */
  587.                 used   = 1;
  588.                 output = ap(consClose,
  589.                       textAsOp(name(whnfHead).text,
  590.                        ap(consSpace,
  591.                         print(pr,FUN_PREC-1,pushed(0),
  592.                          ap(consOpen,NIL)))));
  593.                 }
  594.                 else if (whnfArgs>=2 && sy!=APPLIC) { /* e1+e2 */
  595.                 Syntax a = assocOf(sy);
  596.                 Int    p = precOf(sy);
  597.                 used     = 2;
  598.                 if (whnfArgs>2 || d>p)
  599.                      output = ap(consOpen,output);
  600.                 output = print(pr,(a==RIGHT_ASS?p:1+p),
  601.                           pushed(1),
  602.                       ap(consSpace,
  603.                        textAsOp(name(whnfHead).text,
  604.                         ap(consSpace,
  605.                          print(pr,(a==LEFT_ASS? p:1+p),
  606.                           pushed(0),
  607.                           output)))));
  608.                 if (whnfArgs>2 || d>p)
  609.                     output = ap(consClose,output);
  610.                 }
  611.                 else                  /* f ... */
  612.                 output = textAsVar(name(whnfHead).text,NIL);
  613.             }
  614.             break;
  615.  
  616.     case INTCELL  : {   Int digit;
  617.  
  618.                 if (intOf(whnfHead)<0 && d>=FUN_PREC)
  619.                 output = ap(consClose,output);
  620.  
  621.                 do {
  622.                 digit = whnfInt%10;
  623.                 if (digit<0)
  624.                     digit= (-digit);
  625.                 output = ap(consChar('0'+digit),output);
  626.                 } while ((whnfInt/=10)!=0);
  627.  
  628.                 if (intOf(whnfHead)<0) {
  629.                 output = ap(consMinus,output);
  630.                 if (d>=FUN_PREC)
  631.                     output = ap(consOpen,output);
  632.                 }
  633.  
  634.                 output = rev(output);
  635.                 pr       = nameNPrint;
  636.             }
  637.             break;
  638.  
  639.     case UNIT     : output = ap(consClose,ap(consOpen,NIL));
  640.             pr     = nameNPrint;
  641.             break;
  642.  
  643.     case TUPLE    : {   Int  tn   = tupleOf(whnfHead);
  644.                             Cell punc = consOpen;
  645.                 Int  i;
  646.  
  647.                 used      = tn<whnfArgs ? tn : whnfArgs;
  648.                 output    = NIL;
  649.                 for (i=0; i<used; ++i) {
  650.                 output = print(pr,MIN_PREC,pushed(i),
  651.                       ap(punc,
  652.                        output));
  653.                 punc   = consComma;
  654.                 }
  655.                 for (; i<tn; ++i) {
  656.                 output = ap(punc,output);
  657.                 punc   = consComma;
  658.                 }
  659.                 output = ap(consClose,output);
  660.             }
  661.             pr = nameNPrint;
  662.             break;
  663.  
  664.     case CHARCELL : output = ap(consQuote,
  665.                                   stringOutput(unlexChar(charOf(whnfHead),
  666.                                                          '\''),
  667.                    ap(consQuote,
  668.                     output)));
  669.             pr     = nameNPrint;
  670.             break;
  671.  
  672.     case FLOATCELL: output = stringOutput(floatToString(whnfFloat),
  673.                           output);
  674.             pr     = nameNPrint;
  675.             break;
  676.  
  677.         case DICTCELL : output = stringOutput("{dict}",output);
  678.             pr     = nameNPrint;
  679.             break;
  680.  
  681.     case FILECELL : output = stringOutput("{file}",output);
  682.             pr     = nameNPrint;
  683.             break;
  684.  
  685.     default       : internal("Error in graph");
  686.             break;
  687.     }
  688.  
  689.     if (used<whnfArgs) {        /* Add remaining args to output       */
  690.     do
  691.         output = print(pr,FUN_PREC,pushed(used),ap(consSpace,output));
  692.     while (++used<whnfArgs);
  693.  
  694.     if (d>=FUN_PREC) {        /* Determine if parens are needed  */
  695.         updapRoot(consOpen,revOnto(output,ap(consClose,ss)));
  696.         return;
  697.     }
  698.     }
  699.  
  700.     updateRoot(revOnto(output,ss));
  701. }
  702.  
  703. /* --------------------------------------------------------------------------
  704.  * List printing primitives:
  705.  * ------------------------------------------------------------------------*/
  706.  
  707. static Void local startList(root,ss)    /* start printing evaluated list   */
  708. StackPtr root;
  709. Cell     ss; {
  710.     Cell x    = pushed(0);
  711.     Cell xs   = pushed(1);
  712.     Cell temp = evalWithNoError(x);
  713.     if (nonNull(temp))
  714.     updapRoot(consOsq,
  715.            printBadRedex(temp,
  716.             lprint(nameLPrint,xs,ss)));
  717.     else if (isChar(whnfHead) && whnfArgs==0)
  718.     updapRoot(consDQuote,
  719.            printSChar(charOf(whnfHead),
  720.             lprint(nameSPrint,xs,ss)));
  721.     else
  722.     updapRoot(consOsq,
  723.            print(namePrint,MIN_PREC,x,
  724.             lprint(nameLPrint,xs,ss)));
  725. }
  726.  
  727. static Void local startNList(root,ss)    /* start printing unevaluated list */
  728. StackPtr root;
  729. Cell     ss; {
  730.     Cell x    = pushed(0);
  731.     Cell xs   = pushed(1);
  732.     unwind(x);
  733.     if (isChar(whnfHead) && whnfArgs==0)
  734.     updapRoot(consDQuote,
  735.            printSChar(charOf(whnfHead),
  736.             lprint(nameNSPrint,xs,ss)));
  737.     else
  738.     updapRoot(consOsq,
  739.            print(nameNPrint,MIN_PREC,x,
  740.             lprint(nameNLPrint,xs,ss)));
  741. }
  742.  
  743. primFun(primLPrint) {            /* evaluate and print list       */
  744.     Cell e    = primArg(2);
  745.     Cell ss   = primArg(1);
  746.     Cell temp = evalWithNoError(e);
  747.  
  748.     if (nonNull(temp))
  749.     updateRoot(printString("] ++ ",printBadRedex(temp,ss)));
  750.     else if (whnfHead==nameCons && whnfArgs==2)
  751.     updapRoot(consComma,
  752.            ap(consSpace,
  753.             print(namePrint,MIN_PREC,pushed(0),
  754.              lprint(nameLPrint,pushed(1),ss))));
  755.     else if (whnfHead==nameNil && whnfArgs==0)
  756.     updapRoot(consCsq,ss);
  757.     else
  758.     updateRoot(printString("] ++ ",printBadRedex(e,ss)));
  759. }
  760.  
  761. primFun(primNLPrint) {            /* print list without evaluation   */
  762.     Cell e  = primArg(2);
  763.     Cell ss = primArg(1);
  764.     unwind(e);
  765.     if (whnfHead==nameCons && whnfArgs==2)
  766.     updapRoot(consComma,
  767.            ap(consSpace,
  768.             print(nameNPrint,MIN_PREC,pushed(0),
  769.              lprint(nameNLPrint,pushed(1),ss))));
  770.     else if (whnfHead==nameNil && whnfArgs==0)
  771.     updapRoot(consCsq,ss);
  772.     else
  773.     updateRoot(printString("] ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  774. }
  775.  
  776. primFun(primSPrint) {            /* evaluate and print string       */
  777.     Cell e    = primArg(2);
  778.     Cell ss   = primArg(1);
  779.     Cell temp = evalWithNoError(e);
  780.  
  781.     if (nonNull(temp))
  782.     updateRoot(printString("\" ++ ",printBadRedex(temp,ss)));
  783.     else if (whnfHead==nameCons && whnfArgs==2) {
  784.     Cell x  = pushed(0);
  785.     Cell xs = pushed(1);
  786.     temp    = evalWithNoError(x);
  787.     if (nonNull(temp))
  788.         updateRoot(printString("\" ++ [",
  789.             printBadRedex(temp,
  790.              lprint(nameLPrint,xs,ss))));
  791.     else if (isChar(whnfHead) && whnfArgs==0)
  792.         updateRoot(printSChar(charOf(whnfHead),
  793.                 lprint(nameSPrint,xs,ss)));
  794.     else
  795.         updateRoot(printString("\" ++ [",
  796.             printBadRedex(x,
  797.              lprint(nameLPrint,xs,ss))));
  798.     }
  799.     else if (whnfHead==nameNil && whnfArgs==0)
  800.     updapRoot(consDQuote,ss);
  801.     else
  802.     updateRoot(printString("\" ++ ",printBadRedex(e,ss)));
  803. }
  804.  
  805. primFun(primNSPrint) {            /* print string without eval       */
  806.     Cell e  = primArg(2);
  807.     Cell ss = primArg(1);
  808.     unwind(e);
  809.     if (whnfHead==nameCons && whnfArgs==2) {
  810.     Cell x  = pushed(0);
  811.     Cell xs = pushed(1);
  812.     unwind(x);
  813.     if (isChar(whnfHead) && whnfArgs==0)
  814.         updateRoot(printSChar(charOf(whnfHead),
  815.                 lprint(nameNSPrint,xs,ss)));
  816.     else
  817.         updateRoot(printString("\" ++ [",
  818.             print(nameNPrint,MIN_PREC,x,
  819.              lprint(nameNLPrint,xs,ss))));
  820.     }
  821.     else if (whnfHead==nameNil && whnfArgs==0)
  822.     updapRoot(consDQuote,ss);
  823.     else
  824.     updateRoot(printString("\" ++ ",print(nameNPrint,FUN_PREC-1,e,ss)));
  825. }
  826.  
  827. /* --------------------------------------------------------------------------
  828.  * Auxiliary functions for printer(s):
  829.  * ------------------------------------------------------------------------*/
  830.  
  831. static Cell local textAsVar(t,ss)    /* reverse t as function symbol       */
  832. Text t;                    /* onto output ss           */
  833. Cell ss; {
  834.     String s = textToStr(t);
  835.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  836.     return stringOutput(s,ss);
  837.     else
  838.     return ap(consClose,stringOutput(s,ap(consOpen,ss)));
  839. }
  840.  
  841. static Cell local textAsOp(t,ss)    /* reverse t as op. symbol onto ss */
  842. Text t;
  843. Cell ss; {
  844.     String s = textToStr(t);
  845.     if (isascii(s[0]) && isalpha(s[0]))
  846.     return ap(consBack,stringOutput(s,ap(consBack,ss)));
  847.     else
  848.     return stringOutput(s,ss);
  849. }
  850.  
  851. static Cell local stringOutput(s,ss)    /* reverse string s onto output ss */
  852. String s;
  853. Cell   ss; {
  854.     while (*s)
  855.     ss = ap(consChar(*s++),ss);
  856.     return ss;
  857. }
  858.  
  859. static Cell local printBadRedex(rx,rs)    /* Produce expression to print bad */
  860. Cell rx, rs; {                /* redex and then print rest ...   */
  861.     return ap(consObrace,
  862.         print(nameNPrint,MIN_PREC,rx,
  863.          ap(consCbrace,
  864.           rs)));
  865. }
  866.  
  867. static Cell consCharArray[NUM_CHARS];
  868.  
  869. Cell consChar(c)            /* return application (:) c       */
  870. Char c; {
  871.     if (c<0)
  872.     c += NUM_CHARS;
  873.     return consCharArray[c];
  874. }
  875.  
  876. Void abandon(what,rx)            /* abandon computation           */
  877. String what;
  878. Cell   rx; {
  879.     outputString(errorStream,
  880.          revOnto(stringOutput("\nAborting ",NIL),
  881.          revOnto(stringOutput(what,NIL),
  882.          revOnto(stringOutput(": ",NIL),
  883.              printDBadRedex(rx,nameNil)))),TRUE);
  884.     errAbort();
  885. }
  886.  
  887. /* --------------------------------------------------------------------------
  888.  * Evaluate name, obtaining a C string from a Gofer string:
  889.  * ------------------------------------------------------------------------*/
  890.  
  891. static String local evalName(es)    /* evaluate es :: [Char] and save  */
  892. Cell es; {                /* in char array... return ptr to  */
  893.     static char buffer[FILENAME_MAX+1];    /* string or 0, if error occurs       */
  894.     Int         pos    = 0;
  895.     StackPtr    saveSp = sp;
  896.  
  897.     while (isNull(evalWithNoError(es)))
  898.     if (whnfHead==nameCons && whnfArgs==2) {
  899.         Cell e = pop();        /* avoid leaving anything on stack */
  900.         es       = pop();
  901.         if (isNull(evalWithNoError(e))
  902.             && isChar(whnfHead) && whnfArgs==0
  903.             && pos<FILENAME_MAX)
  904.         buffer[pos++] = charOf(whnfHead);
  905.         else
  906.         break;
  907.     }
  908.     else if (whnfHead==nameNil && whnfArgs==0) {
  909.         buffer[pos] = '\0';
  910.         return buffer;
  911.     }
  912.     else
  913.         break;
  914.  
  915.     sp = saveSp;            /* stack pointer must be the same  */
  916.     return 0;                /* as it was on entry           */
  917. }
  918.  
  919. /* --------------------------------------------------------------------------
  920.  * Dialogue based input/output:
  921.  *
  922.  * N.B. take care when modifying this code - it is rather delicate and even
  923.  * the simplest of changes might create a nasty space leak... you have been
  924.  * warned (please let me know if you think there already is a space leak!).
  925.  * ------------------------------------------------------------------------*/
  926.  
  927. static Name nameReadFile,    nameWriteFile,  nameAppendFile;
  928. static Name nameReadChan,    nameAppendChan, nameEcho;
  929. static Name nameSuccess,     nameStr,         nameFailure;
  930. static Name nameWriteError,  nameReadError,  nameSearchError;
  931. static Name nameFormatError, nameOtherError;
  932.  
  933. static Bool echoChanged;        /* TRUE => echo changed in dialogue*/
  934. static Bool stdinUsed;            /* TRUE => ReadChan stdin has been */
  935.                     /*       seen in dialogue       */
  936. static FILE *writingFile = 0;        /* points to file open for writing */
  937.  
  938. Void dialogue(prog)            /* carry out dialogue ...       */
  939. Cell prog; {                /* :: Dialog=[Response]->[Request] */
  940.     static String ioerr = "Attempt to read response before request complete";
  941.     Cell tooStrict      = mkStr(findText(ioerr));
  942.     Cell resps        = prog = ap(prog,NIL);
  943.     Cell temp;
  944.  
  945.     echoChanged = FALSE;
  946.     stdinUsed   = FALSE;
  947.     for (;;) {                /* Keep Responding to Requests       */
  948.     resps = snd(resps) = ap(nameError,tooStrict);
  949.         clearStack();
  950.     if (nonNull(temp=evalWithNoError(prog)))
  951.         abandonDialogue(temp);
  952.     else if (whnfHead==nameCons && whnfArgs==2) {
  953.         if (nonNull(temp=evalWithNoError(pushed(0))))
  954.         abandonDialogue(temp);
  955.  
  956.         prog = pushed(1+whnfArgs);
  957.  
  958.         if (whnfHead==nameReadFile && whnfArgs==1)
  959.         fst(resps) = ap(nameCons,readFile());
  960.         else if (whnfHead==nameWriteFile && whnfArgs==2)
  961.         fst(resps) = ap(nameCons,writeFile());
  962.         else if (whnfHead==nameAppendFile && whnfArgs==2)
  963.         fst(resps) = ap(nameCons,appendFile());
  964.         else if (whnfHead==nameReadChan && whnfArgs==1)
  965.         fst(resps) = ap(nameCons,readChan());
  966.         else if (whnfHead==nameAppendChan && whnfArgs==2)
  967.         fst(resps) = ap(nameCons,appendChan());
  968.         else if (whnfHead==nameEcho && whnfArgs==1)
  969.         fst(resps) = ap(nameCons,echo());
  970.         else
  971.         abandonDialogue(pushed(whnfArgs));
  972.     }
  973.     else if (whnfHead==nameNil && whnfArgs==0) {
  974.         normalTerminal();
  975.         return;
  976.     }
  977.     else
  978.         internal("Type error during Dialogue");
  979.     }
  980. }
  981.  
  982. static Void local abandonDialogue(rx)    /* abandon dialogue after failure  */
  983. Cell rx; {                /* to reduce redex rx           */
  984.     abandon("Dialogue",rx);
  985. }
  986.  
  987. static Cell local printDBadRedex(rx,rs) /* Produce expression for bad redex*/
  988. Cell rx, rs; {                /* within a Dialogue, with special */
  989.     if (isAp(rx) && fun(rx)==nameError) /* handling of {error str} redexes */
  990.     return arg(rx);
  991.     else
  992.     return printBadRedex(rx,rs);
  993. }
  994.  
  995. static Cell local readFile() {        /* repond to ReadFile request       */
  996.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  997.     Cell   temp = NIL;            /* pushed(1) = ReadFile request       */
  998.                     /* pushed(2) = rest of program       */
  999.  
  1000.     if (!s)                /* problem with filename?       */
  1001.     abandonDialogue(pushed(1));
  1002.     if (access(s,0)!=0)            /* can't find file           */ 
  1003.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1004.     if (isNull(temp = openFile(s)))    /* can't open file           */
  1005.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1006.     return ap(nameStr,temp);        /* otherwise we got a file!       */
  1007. }
  1008.  
  1009. static Cell local writeFile() {        /* respond to WriteFile req.       */
  1010.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1011.     FILE   *fp;                /* pushed(1) = output string       */
  1012.     Cell   temp;            /* pushed(2) = output request       */
  1013.                     /* pushed(3) = rest of program       */
  1014.  
  1015.     if (!s)                /* problem with filename?          */
  1016.         abandonDialogue(pushed(2));
  1017.     if ((fp=fopen(s,FOPEN_WRITE))==0)    /* problem with output file?       */
  1018.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1019.     writingFile = fp;
  1020.     temp        = outputString(fp,pushed(1),FALSE);
  1021.     fclose(fp);
  1022.     writingFile = 0;
  1023.     if (nonNull(temp))
  1024.     return ap(nameFailure,ap(nameWriteError,temp));
  1025.     else
  1026.     return nameSuccess;
  1027. }
  1028.  
  1029. static Cell local appendFile() {    /* respond to AppendFile req.       */
  1030.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1031.     FILE   *fp;                /* pushed(1) = output string       */
  1032.     Cell   temp;            /* pushed(2) = output request       */
  1033.                     /* pushed(3) = rest of program       */
  1034.  
  1035.     if (!s)                /* problem with filename?          */
  1036.         abandonDialogue(pushed(2));
  1037.     if (access(s,0)!=0)            /* can't find file?           */
  1038.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1039.     if ((fp=fopen(s,FOPEN_APPEND))==0)    /* problem with output file?       */
  1040.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1041.     writingFile = fp;
  1042.     temp        = outputString(fp,pushed(1),FALSE);
  1043.     fclose(fp);
  1044.     writingFile = 0;
  1045.     if (nonNull(temp))
  1046.     return ap(nameFailure,ap(nameWriteError,temp));
  1047.     else
  1048.     return nameSuccess;
  1049. }
  1050.  
  1051. static Cell local readChan() {        /* respond to readChan req.       */
  1052.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1053.                     /* pushed(1) = output request       */
  1054.                     /* pushed(2) = rest of program       */
  1055.  
  1056.     if (!s)                /* problem with filename?       */
  1057.     abandonDialogue(pushed(1));
  1058.     if (strcmp(s,"stdin")!=0)        /* only valid channel == stdin       */
  1059.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1060.     if (stdinUsed)            /* can't reuse stdin channel!      */
  1061.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1062.     stdinUsed = TRUE;
  1063.     return ap(nameStr,ap(nameInput,UNIT));
  1064. }
  1065.  
  1066. static Cell local appendChan() {    /* respond to AppendChannel req.   */
  1067.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1068.     FILE   *fp;                /* pushed(1) = output string       */
  1069.     Cell   temp;            /* pushed(2) = output request       */
  1070.                     /* pushed(3) = rest of program       */
  1071.  
  1072.     if (!s)                /* problem with filename?          */
  1073.         abandonDialogue(pushed(2));
  1074.     if ((fp = validOutChannel(s))==0)    /* problem with output channel?       */
  1075.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1076.     if (nonNull(temp=outputString(fp,pushed(1),FALSE)))
  1077.     return ap(nameFailure,ap(nameWriteError,temp));
  1078.     else
  1079.     return nameSuccess;
  1080. }
  1081.  
  1082. static FILE *local validOutChannel(s)    /* return FILE * for valid output  */
  1083. String s; {                /* channel name or 0 otherwise...  */
  1084.     if (strcmp(s,"stdout")==0)
  1085.     return stdout;
  1086.     if (strcmp(s,"stderr")==0)
  1087.     return stderr;
  1088.     if (strcmp(s,"stdecho")==0)        /* in Gofer, stdecho==stdout       */
  1089.     return stdout;
  1090.     return 0;
  1091. }
  1092.  
  1093. static Cell local echo() {        /* respond to Echo request       */
  1094.                         /* pushed(0) = boolean echo status */
  1095.                     /* pushed(1) = echo request       */
  1096.                     /* pushed(2) = rest of program       */
  1097.     static String inUse  = "stdin already in use";
  1098.     static String repeat = "repeated Echo request";
  1099.  
  1100.     if (isNull(evalWithNoError(pushed(0)))) {
  1101.     if (stdinUsed)
  1102.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(inUse))));
  1103.     if (echoChanged)
  1104.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(repeat))));
  1105.     if (whnfHead==nameFalse && whnfArgs==0) {
  1106.         echoChanged = TRUE;
  1107.         noechoTerminal();
  1108.         return nameSuccess;
  1109.     }
  1110.     if (whnfHead==nameTrue && whnfArgs==0) {
  1111.         echoChanged = TRUE;
  1112.         return nameSuccess;
  1113.     }
  1114.     }
  1115.     abandonDialogue(pushed(1));
  1116.     return NIL;/*NOTREACHED*/
  1117. }
  1118.  
  1119. primFun(primInput) {            /* read single character from stdin*/
  1120.     Int c = readTerminalChar();
  1121.  
  1122.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  1123.     clearerr(stdin);
  1124.     updateRoot(nameNil);
  1125.     }
  1126.     else
  1127.     updapRoot(consChar(c),ap(nameInput,UNIT));
  1128. }
  1129.  
  1130. /* --------------------------------------------------------------------------
  1131.  * Top-level printing mechanism:
  1132.  * ------------------------------------------------------------------------*/
  1133.  
  1134. Cell outputString(fp,cs,noDialogue)    /* Evaluate string cs and print       */
  1135. FILE *fp;                /* on specified output stream fp   */
  1136. Cell cs;
  1137. Bool noDialogue; {            /* TRUE => not runnning Dialogue   */
  1138.     Cell temp;
  1139.  
  1140.     for (;;) {                /* keep reducing and printing head */
  1141.     clearStack();            /* character               */
  1142.     temp = evalWithNoError(cs);
  1143.     if (nonNull(temp))
  1144.         if (noDialogue)
  1145.         cs = printBadRedex(temp,nameNil);
  1146.         else
  1147.         return printDBadRedex(temp,nameNil);
  1148.     else if (whnfHead==nameCons && whnfArgs==2) {
  1149.         Cell c = pushed(0);
  1150.         cs     = pushed(1);
  1151.  
  1152.         if (nonNull(temp=evalWithNoError(c)))
  1153.         if (noDialogue)
  1154.             cs = printBadRedex(temp,cs);
  1155.         else
  1156.             return printDBadRedex(temp,cs);
  1157.         else if (isChar(whnfHead) && whnfArgs==0) {
  1158.         fputc(charOf(whnfHead),fp);
  1159.         fflush(fp);
  1160.         }
  1161.         else
  1162.         break;
  1163.     }
  1164.     else if (whnfHead==nameNil && whnfArgs==0)
  1165.         return NIL;
  1166.     else
  1167.         break;
  1168.     }
  1169.     internal("runtime type error");
  1170.     return nameNil;/*NOTREACHED*/
  1171. }
  1172.  
  1173. /* --------------------------------------------------------------------------
  1174.  * Built-in control:
  1175.  * ------------------------------------------------------------------------*/
  1176.  
  1177. Void builtIn(what)
  1178. Int what; {
  1179.     Int i;
  1180.  
  1181.     switch (what) {
  1182.     case RESET   : if (writingFile) {
  1183.                fclose(writingFile);
  1184.                writingFile = 0;
  1185.                }
  1186.                break;
  1187.  
  1188.     case MARK    : for (i=0; i<NUM_CHARS; ++i)
  1189.                mark(consCharArray[i]);
  1190.                break;
  1191.  
  1192.     case INSTALL : for (i=0; i<NUM_CHARS; ++i)
  1193.                consCharArray[i] = ap(nameCons,mkChar(i));
  1194.  
  1195.                consOpen       = consCharArray['('];
  1196.                consSpace      = consCharArray[' '];
  1197.                consComma      = consCharArray[','];
  1198.                consClose      = consCharArray[')'];
  1199.                consObrace     = consCharArray['{'];
  1200.                consCbrace     = consCharArray['}'];
  1201.                consOsq          = consCharArray['['];
  1202.                consCsq          = consCharArray[']'];
  1203.                consBack       = consCharArray['`'];
  1204.                consMinus      = consCharArray['-'];
  1205.                consQuote      = consCharArray['\''];
  1206.                consDQuote     = consCharArray['\"'];
  1207.  
  1208. #define pFun(s,a,t,i)  addPrim(newName(findText(s)),a,t,i)
  1209.                nameFatbar     = pFun("_FATBAR",2,NIL,primFatbar);
  1210.                nameFail       = pFun("_FAIL",0,NIL,primFail);
  1211.                nameIf          = pFun("_IF",3,NIL,primIf);
  1212.                nameSel          = pFun("_SEL",3,NIL,primSel);
  1213.                nameMinus      = pFun("_minus",2,NIL,primMinusInt);
  1214.                nameDivide     = pFun("_divide",2,NIL,primDivInt);
  1215.                nameUndefMem   = pFun("undefined_member",1,NIL,
  1216.                         primUndefMem);
  1217.  
  1218.                namePrimCmp    = pFun("_compare",1,NIL,primCmp);
  1219.  
  1220.                namePrint      = pFun("_print",3,NIL,primPrint);
  1221.                nameNPrint     = pFun("_nprint",3,NIL,primNPrint);
  1222.                nameLPrint     = pFun("_lprint",2,NIL,primLPrint);
  1223.                nameNLPrint    = pFun("_nlprint",2,NIL,primNLPrint);
  1224.                nameSPrint     = pFun("_sprint",2,NIL,primSPrint);
  1225.                nameNSPrint    = pFun("_nsprint",2,NIL,primNSPrint);
  1226.  
  1227.                nameInput      = pFun("_input",1,NIL,primInput);
  1228. #undef pFun
  1229. #define predef(nm,str) nm=newName(findText(str)); name(nm).defn=PREDEFINED
  1230.                predef(nameReadFile,    "ReadFile");
  1231.                predef(nameWriteFile,    "WriteFile");
  1232.                predef(nameAppendFile,    "AppendFile");
  1233.                predef(nameReadChan,    "ReadChan");
  1234.                predef(nameAppendChan,    "AppendChan");
  1235.                predef(nameEcho,        "Echo");
  1236.                predef(nameSuccess,    "Success");
  1237.                predef(nameStr,        "Str");
  1238.                predef(nameFailure,    "Failure");
  1239.                predef(nameWriteError,    "WriteError");
  1240.                predef(nameReadError,    "ReadError");
  1241.                predef(nameSearchError,    "SearchError");
  1242.                predef(nameFormatError,    "FormatError");
  1243.                predef(nameAnd,        "&&");
  1244.                predef(nameOr,        "||");
  1245.                predef(nameError,    "error");
  1246. #undef  predef
  1247.                break;
  1248.     }
  1249. }
  1250.  
  1251. /*-------------------------------------------------------------------------*/
  1252.